home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Deutsche Edition 1
/
Deutsche Edition 1.iso
/
amok
/
041-050
/
amok48
/
module
/
txt
/
newinout.mod
< prev
next >
Wrap
Text File
|
1993-11-04
|
21KB
|
681 lines
(**********************************************************************
:Program. NewInOut.mod
:Contens. Ein Bibliotheksmodul für gepufferte Ein- und Ausgabe.
:Contens. Kompatibel zu InOut.
:Author. Bernd Braun
:Address. Lippestr. 11, D-3300 Braunschweig
:Phone. 0531/845498
:Copyright. Public Domain
:Language. Modula-2
:Translator. M2Amiga A+L V3.32d
:Support. Tooltype-Übergabe nach Amiga 12/89 S.86f. Andreas Görtler.
:History. V1.0 25.Sep.1989 Erste lauffähige Version
:History. V1.1 26.Apr.1990 Kosmetische Verbesserungen
:History. V1.2 26.Sep.1990 Tooltypeübergabe implementiert
:History. V1.3 22.Dez.1990 Jeweils bei Read-String, -Int, -LongInt,
:History. -Card und -LongCard FlushOutput eingefügt.
***********************************************************************)
(* $R- $V- $S- $F- *) (* Programm läuft bisher ohne Fehler. *)
IMPLEMENTATION MODULE NewInOut;
FROM Arts IMPORT
startupMsg, TermProcedure, Assert, wbStarted;
FROM ASCII IMPORT
eof, nul, cr, bs, sp, csi;
FROM Conversions IMPORT
StrToVal, ValToStr;
FROM Dos IMPORT
Input, Output, FileHandlePtr, WaitForChar, oldFile, newFile;
IMPORT Dos;
FROM Icon IMPORT
GetDiskObject, FreeDiskObject, FindToolType;
FROM Storage IMPORT
ALLOCATE, DEALLOCATE;
FROM SYSTEM IMPORT
ADR, TSIZE, CAST;
FROM Workbench IMPORT
WBStartupPtr, DiskObjectPtr;
CONST
buflen = 1024;
(* Länge der Ein- und Ausgabe-Puffer. *)
filemsg = 'File ist nicht geöffnet!';
winerror = 'Fehler bein Öffnen des Windows!';
defwin = 'con:0/50/640/150/NewInOut';
memerror = 'Kein Speicher mehr frei!';
Tooltype = 'WINDOW';
TYPE
buffer = ARRAY [ 0 .. buflen - 1] OF CHAR;
(* Typ der Ein- und Ausgabe-Puffer. *)
FILE = POINTER TO FILEREC;
FILEREC = RECORD
inbuffer, outbuffer : buffer;
inbufptr,
outbufptr, inbufmax : INTEGER;
handle : FileHandlePtr;
END;
(* Ein File besteht aus einem Ein- und einem Ausgabepuffer, zwei
Zeiger auf das aktuelle Zeichen im Ein- und Ausgabepuffer, einem
Zeiger auf die Maximale Anzahl Zeichen im Eingabe-Puffer und
einem Pointer auf den DOSFileHandlePointer. *)
FileListPtr = POINTER TO FileList;
FileList = RECORD
file : FILE;
next : FileListPtr;
END;
(* In der FileListe werden alle geöffneten Files in einer einfachen
linearen Liste gespeichert. *)
StringPtr = POINTER TO String;
String = ARRAY [ 0 .. 107 ] OF CHAR;
VAR
ownwindow : BOOLEAN;
out : FILE;
FileListe : FileListPtr;
oldout, oldin : FILE;
(* Speicherung der alten stdin und stdout für OpenInput,
OpenOutput. *)
wbstartupptr : WBStartupPtr;
stringptr : StringPtr;
diskobjectptr : DiskObjectPtr;
toolarrayptr : POINTER TO StringPtr;
(* Berechnung der Lände eines Strings. *)
PROCEDURE Length ( Str : ARRAY OF CHAR ) : INTEGER;
VAR
len : INTEGER;
BEGIN
len := 0;
WHILE ( len <= HIGH ( Str ) ) AND ( Str [ len ] # nul ) DO
INC ( len );
END;
RETURN len;
END Length;
(* Initialieren eines Files. *)
PROCEDURE InitFile ( Handle : FileHandlePtr ) : FILE;
VAR
file : FILE;
BEGIN
ALLOCATE ( file, TSIZE ( FILEREC ) );
Assert ( file # NIL, ADR ( memerror ) );
WITH file ^ DO
outbufptr := 0;
inbufmax := 0;
inbufptr := 0;
handle := Handle;
END;
RETURN file;
END InitFile;
(* Schreiben aller Zeichen im Output-Puffer in file. *)
PROCEDURE FlushOutput ( file : FILE );
VAR
len : LONGINT;
BEGIN
Assert ( file # NIL, ADR ( filemsg ) );
done := TRUE;
WITH file ^ DO
IF outbufptr > 0 THEN
len := Dos.Write ( handle, ADR ( outbuffer ), outbufptr );
done := len = outbufptr;
outbufptr := 0;
END;
END;
END FlushOutput;
(* Öffnen eines beliebigen Amiga-DOS Files. *)
PROCEDURE Open ( Datei : ARRAY OF CHAR; modus : Modus ) : FILE;
VAR
handle : FileHandlePtr;
newfile : FILE;
p, q : FileListPtr;
DOSModus : CARDINAL;
len, n : INTEGER;
Str : String;
BEGIN
done := TRUE;
len := Length ( Datei );
IF len = 0 THEN
(* Standart Ein- und Ausgabe. *)
IF modus = ModeOld THEN
newfile := stdin;
ELSE
newfile := stdout;
END;
ELSE
(* Konstante Strings haben kein nul-Zeichen am Ende.
AmigaDOS-Open erwartet aber ein nul-Zeichen am Ende des
Dateinamens. Deshalb diese umkopiererei. *)
FOR n := 0 TO len - 1 DO
Str [ n ] := Datei [ n ];
END;
Str [ len ] := nul;
IF modus = ModeOld THEN
DOSModus := oldFile;
ELSE
DOSModus := newFile;
END;
handle := Dos.Open ( ADR ( Str ), DOSModus );
IF handle = NIL THEN
(* File existiert nicht. *)
done := FALSE;
newfile := NIL;
ELSE
newfile := InitFile ( handle );
(* Anhängen des Files in die FileListe. *)
p := FileListe;
q := p;
WHILE p # NIL DO
q := p;
p := p ^. next;
END;
ALLOCATE ( p, TSIZE ( FileList ) );
Assert ( p # NIL, ADR ( memerror ) );
IF q # NIL THEN
q ^. next := p;
ELSE
FileListe := p;
END;
WITH p ^ DO
file := newfile;
next := NIL;
END;
END;
END;
RETURN newfile;
END Open;
(* Öffnen eines neuen Ausgabefiles anstelle stdin. In Datei steht das
zu öffnende Amiga-DOS File. Ist Datei leer wird ein Filename per
Tastatur angefragt.
Änderung gegenüber InOut:
- In Datei darf keine Extention wie '.mod' stehen sondern der
Dateiname oder ein Leerstring.
- Der Dateiname kann vorher ggf. mit ReadString eingegeben
werden. *)
PROCEDURE OpenInput ( Datei : ARRAY OF CHAR );
VAR
Str : ARRAY [ 0 .. 79 ] OF CHAR;
BEGIN
(* done wird von Open gesetzt. *)
IF Length ( Datei ) # 0 THEN
(* Angegebens File öffnen. *)
stdin := Open ( Datei, ModeOld );
IF stdin = NIL THEN
stdin := oldin;
END;
ELSE
(* Filename anfragen. *)
WriteStringFile ( oldout, 'newin>' );
FlushOutput ( oldout );
ReadStringFile ( oldin, Str );
IF Str [ 0 ] # '*' THEN
stdin := Open ( Str, ModeOld );
IF stdin = NIL THEN
stdin := oldin;
END;
END;
END;
END OpenInput;
(* Öffnen eines neuen Ausgabefiles anstelle stdout. In Datei steht das
zu öffnende Amiga-DOS File. Ist Datei leer wird ein Filename per
Tastatur angefragt.
Änderung gegenüber InOut:
- In Datei darf keine Extention wie '.mod' stehen sondern der
Dateiname oder ein Leerstring.
- Der Dateiname kann vorher ggf. mit ReadString eingegeben
werden. *)
PROCEDURE OpenOutput ( Datei : ARRAY OF CHAR );
VAR
Str : ARRAY [ 0 .. 79 ] OF CHAR;
BEGIN
(* done wird von Open gesetzt. *)
IF Length ( Datei ) # 0 THEN
stdout := Open ( Datei, ModeNew );
IF stdout = NIL THEN
stdout := oldout;
END;
ELSE
WriteStringFile ( oldout, 'newout>' );
FlushOutput ( oldout );
ReadStringFile ( oldin, Str );
IF Str [ 0 ] # '*' THEN
stdout := Open ( Str, ModeNew );
IF stdout = NIL THEN
stdout := oldout;
END;
END;
END;
END OpenOutput;
(* Schließen eines geöffneten Files. *)
PROCEDURE Close ( file : FILE );
BEGIN
(* Restliche Zeichen im Puffer ins File schreiben. *)
FlushOutput ( file );
IF file # NIL THEN
WITH file ^ DO
IF handle # NIL THEN
Dos.Close ( handle );
handle := NIL;
END;
END;
file := NIL;
END;
END Close;
(* Schließen eines geöffneten Eingabefiles und Wiedereinsetzen von
stdin. *)
PROCEDURE CloseInput;
BEGIN
IF oldin # stdin THEN
Close ( stdin );
stdin := oldin;
END;
END CloseInput;
(* Schließen eines geöffneten Ausgabefiles und Wiedereinsetzen von
stdout. *)
PROCEDURE CloseOutput;
BEGIN
IF oldout # stdout THEN
Close ( stdout );
stdout := oldout;
END;
END CloseOutput;
(* Rückgabe des ersten Zeichens im Eingabepuffer von file. Ist er leer
werden neue Zeichen aus file gelesen und im Eingabepuffer
gespeichert. *)
PROCEDURE ReadFile ( file : FILE; VAR c : CHAR );
VAR
len : LONGINT;
BEGIN
Assert ( file # NIL, ADR ( filemsg ) );
FlushOutput ( file );
done := TRUE;
WITH file ^ DO
IF inbufptr = inbufmax THEN
(* Eingabepuffer ist leer. *)
len := Dos.Read ( handle, ADR ( inbuffer ), buflen );
IF len <= 0 THEN
(* Ende des Files. *)
done := FALSE;
c := eof;
RETURN;
ELSE;
inbufptr := 0;
inbufmax := len - 1;
END;
ELSE
INC ( inbufptr );
END;
c := inbuffer [ inbufptr ];
END;
END ReadFile;
(* Rückgabe eines Zeichens aus stdin mit Hilfe von ReadFile. *)
PROCEDURE Read ( VAR c : CHAR );
BEGIN
ReadFile ( stdin, c );
END Read;
(* Speichern eines Zeichens im Ausgabepuffer von file. Ist er voll
werden alle Zeichen im Ausgabepuffer in file geschrieben. *)
PROCEDURE WriteFile ( file : FILE; c : CHAR );
BEGIN
Assert ( file # NIL, ADR ( filemsg ) );
WITH file ^ DO
IF outbufptr >= buflen THEN
FlushOutput ( file );
END;
outbuffer [ outbufptr ] := c;
INC ( outbufptr );
END;
END WriteFile;
(* Schreiben eines Zeichens in stdout mit Hilfe von WriteFile. *)
PROCEDURE Write ( c : CHAR );
BEGIN
WriteFile ( stdout, c );
END Write;
(* Schreiben eines Strings in file. *)
PROCEDURE WriteStringFile ( file : FILE; Text : ARRAY OF CHAR );
VAR
len, n : INTEGER;
BEGIN
Assert ( file # NIL, ADR ( filemsg ) );
len := Length ( Text ) - 1;
FOR n := 0 TO len DO
WriteFile ( file, Text [ n ] );
END;
END WriteStringFile;
(* Schreiben eines String in stdout mit Hilfe von WriteStringFile. *)
PROCEDURE WriteString ( Text : ARRAY OF CHAR );
BEGIN
WriteStringFile ( stdout, Text );
END WriteString;
(* Schreiben einer neuen Zeile in File mit Hilfe von WriteFile. *)
PROCEDURE WriteLnFile ( file : FILE );
BEGIN
WriteFile ( file, eol );
FlushOutput ( file );
END WriteLnFile;
(* Schreiben einer neuen Zeile in stdout mit Hilfe von WriteLnFile. *)
PROCEDURE WriteLn;
BEGIN
WriteLnFile ( stdout );
END WriteLn;
(* Eingabe eines Strings aus file.
Procedure ist für con-Windows und bel. Files geschrieben.
Kann gegen Procedur für raw-Windows ausgetauscht werden. *)
PROCEDURE ReadStringFile ( file : FILE; VAR Text : ARRAY OF CHAR );
VAR
len : INTEGER;
c : CHAR;
BEGIN
Assert ( file # NIL, ADR ( filemsg ) );
len := 0;
(* Führende Leerzeichen überlesen. *)
REPEAT
ReadFile ( file, c );
UNTIL ( c = eof ) OR ( c # ' ');
WHILE ( c # eof ) AND ( c # eol ) AND ( len <= HIGH ( Text ) ) DO
Text [ len ] := c;
INC ( len );
ReadFile ( file, c );
END;
IF len <= HIGH ( Text ) THEN
Text [ len ] := nul;
END;
done := ( len # 0 ) AND ( c # eof );
END ReadStringFile;
(* Eingabe eines Strings aus stdin mit Hilfe von ReadStringFile. *)
PROCEDURE ReadString ( VAR Text : ARRAY OF CHAR );
BEGIN
FlushOutput ( stdout ); (* Bei Cli Ausgabe flushen. *)
ReadStringFile ( stdin, Text );
END ReadString;
(* Eingabe eines Cardinal aus file. *)
PROCEDURE ReadCardFile ( file : FILE; VAR Card : CARDINAL );
VAR
Str : ARRAY [ 0 .. 79 ] OF CHAR;
val : LONGINT;
sig, err : BOOLEAN;
BEGIN
Card := 0;
ReadStringFile ( file, Str );
IF done THEN
sig := FALSE;
StrToVal ( Str, val, sig, 10, err );
IF NOT err AND ( val >= 0 ) AND ( val <= 65535 ) THEN
Card := CARDINAL ( val );
ELSE
done := FALSE;
END;
END;
END ReadCardFile;
(* Eingabe eines Cardinal aus stdin mit Hilfe von ReadCardFile. *)
PROCEDURE ReadCard ( VAR Card : CARDINAL );
BEGIN
FlushOutput ( stdout ); (* Bei Cli Ausgabe flushen. *)
ReadCardFile ( stdin, Card );
END ReadCard;
(* Eingabe eines LongCardinal aus file. *)
PROCEDURE ReadLongCardFile ( file : FILE; VAR Card : LONGCARD );
VAR
Str : ARRAY [ 0 .. 79 ] OF CHAR;
val : LONGINT;
sig, err : BOOLEAN;
BEGIN
Card := 0;
ReadStringFile ( file, Str );
IF done THEN
sig := FALSE;
StrToVal ( Str, val, sig, 10, err );
IF NOT err AND ( val >= 0 ) THEN
Card := LONGCARD ( val );
ELSIF ( val < 0 ) AND NOT sig THEN
Card := CAST ( LONGCARD, val );
ELSE
done := FALSE;
END;
END;
END ReadLongCardFile;
(* Eingabe eines LongCardinal aus stdin mit Hilfe von ReadCardFile. *)
PROCEDURE ReadLongCard ( VAR Card : LONGCARD );
BEGIN
FlushOutput ( stdout ); (* Bei Cli Ausgabe flushen. *)
ReadLongCardFile ( stdin, Card );
END ReadLongCard;
(* Eingabe eines Integer aus file. *)
PROCEDURE ReadIntFile ( file : FILE; VAR Int : INTEGER );
VAR
Str : ARRAY [ 0 .. 79 ] OF CHAR;
val : LONGINT;
sig, err : BOOLEAN;
BEGIN
Int := 0;
ReadStringFile ( file, Str );
IF done THEN
sig := TRUE;
StrToVal ( Str, val, sig, 10, err );
IF NOT err AND ( val >= -32768 )
AND ( val <= 32767 ) THEN
Int := INTEGER ( val );
ELSE
done := FALSE;
END;
END;
END ReadIntFile;
(* Eingabe eines Integer aus stdin mit Hilfe von ReadCardFile. *)
PROCEDURE ReadInt ( VAR Int : INTEGER );
BEGIN
FlushOutput ( stdout ); (* Bei Cli Ausgabe flushen. *)
ReadIntFile ( stdin, Int );
END ReadInt;
(* Eingabe eines LongInteger aus file. *)
PROCEDURE ReadLongIntFile ( file : FILE; VAR Int : LONGINT );
VAR
Str : ARRAY [ 0 .. 79 ] OF CHAR;
sig, err : BOOLEAN;
BEGIN
Int := 0;
ReadStringFile ( file, Str );
IF done THEN
sig := TRUE;
StrToVal ( Str, Int, sig, 10, err );
IF err OR NOT sig AND ( Int < 0 ) THEN
Int := 0;
done := FALSE;
END;
END;
END ReadLongIntFile;
(* Eingabe eines LongInteger aus stdin mit Hilfe von ReadCardFile. *)
PROCEDURE ReadLongInt ( VAR Int : LONGINT );
BEGIN
FlushOutput ( stdout ); (* Bei Cli Ausgabe flushen. *)
ReadLongIntFile ( stdin, Int );
END ReadLongInt;
(* Schreiben eines Cardinal oder LongCardinal in file mit der
Feldbreite Feld.
Ist Feld positiv rechtsbündig, bei negativ linksbündig.*)
PROCEDURE WriteCardFile ( file : FILE;
Card : LONGCARD;
Feld : INTEGER );
VAR
Str : ARRAY [ 0 .. 80 ] OF CHAR;
err : BOOLEAN;
BEGIN
ValToStr ( CAST ( LONGINT, Card ), FALSE, Str, 10, Feld, ' ',
err );
WriteStringFile ( file, Str );
END WriteCardFile;
(* Schreiben eines Cardinal oder LongCardinal in stdout mit der
Feldbreite Feld mit Hilfe von WriteCardFile.
Ist Feld positiv rechtsbündig, bei negativ linksbündig.*)
PROCEDURE WriteCard ( Card : LONGCARD; Feld : INTEGER );
BEGIN
WriteCardFile ( stdout, Card, Feld );
END WriteCard;
(* Schreiben eines Integer oder LongInteger in file mit der
Feldbreite Feld.
Ist Feld positiv rechtsbündig, bei negativ linksbündig.*)
PROCEDURE WriteIntFile ( file : FILE;
Int : LONGINT;
Feld : INTEGER );
VAR
Str : ARRAY [ 0 .. 80 ] OF CHAR;
err : BOOLEAN;
BEGIN
ValToStr ( Int, TRUE, Str, 10, Feld, ' ', err );
WriteStringFile ( file, Str );
END WriteIntFile;
(* Schreiben eines Integer oder LongInteger in stdout mit der
Feldbreite Feld mit Hilfe von WriteCardFile.
Ist Feld positiv rechtsbündig, bei negativ linksbündig.*)
PROCEDURE WriteInt ( Int : LONGINT; Feld : INTEGER );
BEGIN
WriteIntFile ( stdout, Int, Feld );
END WriteInt;
(* Schreiben eines Cardinal oder LongCardinal als HexZahl in file mit
der Feldbreite Feld.
Ist Feld positiv rechtsbündig, bei negativ linksbündig.*)
PROCEDURE WriteHexFile ( file : FILE;
Hex : LONGCARD;
Feld : INTEGER );
VAR
Str : ARRAY [ 0 .. 80 ] OF CHAR;
err : BOOLEAN;
c : CHAR;
BEGIN
IF Feld >= 0 THEN
c := '0';
(* Als führende Zeichen ein '0'. *)
ELSE
c := ' ';
(* Als nachfolgende Zeichen ein ' '. *)
END;
ValToStr ( Hex, TRUE, Str, 16, Feld, c, err );
WriteStringFile ( file, Str );
END WriteHexFile;
(* Schreiben eines Cardinal oder LongCardinal als HexZahl in stdout
mit der Feldbreite Feld mit Hilfe von WriteHexFile.
Ist Feld positiv rechtsbündig, bei negativ linksbündig.*)
PROCEDURE WriteHex ( Hex : LONGCARD; Feld : INTEGER );
BEGIN
WriteHexFile ( stdout, Hex, Feld );
END WriteHex;
(* Abschlußprocedur, die alle geöffneten Files wieder schließt. *)
PROCEDURE TermNewInOut;
VAR
p, q : FileListPtr;
BEGIN
IF ( out # NIL ) AND waitCloseGadget THEN
WriteLn;
WriteString ( '<ENTER>' );
FlushOutput ( out );
REPEAT
UNTIL WaitForChar ( out ^. handle, 600 );
END;
IF NOT wbStarted THEN
(* Standarteingabe flushen. *)
FlushOutput ( stdout );
END;
(* Schließen aller Files in der FileListe. *)
q := FileListe;
WHILE q # NIL DO
p := q ^. next;
FlushOutput ( q ^. file );
Close ( q ^. file );
DEALLOCATE ( q ^. file, TSIZE ( FILEREC ) );
DEALLOCATE ( q, TSIZE ( FileList ) );
q := p;
END;
IF diskobjectptr # NIL THEN
FreeDiskObject ( diskobjectptr );
END;
END TermNewInOut;
BEGIN
TermProcedure ( TermNewInOut );
(* Nach Programmschluß ( auch bei Absturz ) wird TermNewInOut
aufgerufen. *)
(* Beim Benutzen eines raw: Windows muß ein neues Window geöffnet
werden auch wenn das Programm vom CLI aus aufgerufen wird.
Die Abfrage auf wbStarted ist für con: Windows gedacht, denn bei
CLI-Start wird kein neues Window gebraucht. *)
ownwindow := TRUE;
waitCloseGadget := TRUE;
FileListe := NIL;
out := NIL;
diskobjectptr := NIL;
stdin := NIL;
stdout := NIL;
IF wbStarted THEN
(* Tooltype holen, falls vorhanden. *)
wbstartupptr := startupMsg;
diskobjectptr := GetDiskObject
( wbstartupptr ^. argList ^ [ 0 ] . name );
(* diskobjectptr = NIL kann vorkommen wenn mit dem Debugger
gearbeitet wird. Deshalb hier kein Assert verwenden. *)
IF diskobjectptr # NIL THEN
toolarrayptr := diskobjectptr ^. toolTypes;
stringptr := toolarrayptr ^;
END;
IF stringptr # NIL THEN
(* WINDOW-Eintrag suchen. *)
stringptr := FindToolType
( diskobjectptr ^. toolTypes, ADR ( Tooltype ) );
IF stringptr # NIL THEN
out := Open ( stringptr ^, ModeNew );
Assert ( out # NIL, ADR ( winerror ) );
ownwindow := FALSE;
END;
END;
IF ownwindow THEN
(* Window-Voreinstellung. *)
out := Open ( defwin, ModeNew );
Assert ( out # NIL, ADR ( winerror ) );
END;
stdout := out;
stdin := stdout;
ELSE
stdout := InitFile ( Output () );
stdin := InitFile ( Input () );
(* Ein- und Ausgabeumlenkung aus dem CLI wird übernommen. *)
END;
oldin := stdin;
oldout := stdout;
END NewInOut.